Optional Dorothy.f

{


NOTES:
  now, a new big simplification: normal Forth takes precedence.
  inference inside MACRO:'s has been disabled.
  constructor and destructor are not used
  all dorothy words and methods take an object of the word's type at the top of the stack
  added delegates instead of interfaces for now. like everything else it's all very hacked together;
    the usage for now is:
    type: <name>
      delegate <whatever>
    end-type
    :NONAME p.. ; >DELEGATE <type> <delegate>

    also, you can't define more than 16 new delegates per type.

TODO, in order of importance

This probably needs to be rewritten one more time.
  type.action is not working.



fields and constrefs - done
pointers and refs  - done
type inference
   from name - done
   from THIS - part of methods
methods - done
[] etc - in progress
locals - very low priority due to the time it will take to do it
re-enable inference inside macros - maybe not needed?
extend SEE, LOCATE, and EDIT
>< for overriding Dorothy on the next word


IDEAS:
   ANY.COPY could be used to copy field arrays. (right now it would only copy the first element)

PROBLEMS:
   possible conflicts with value names and dorothy words
   macros aren't working
   just a POTENTIAL problem, not sure yet: only the top of the hint stack matters.
   you can't use "static methods" in methods. (typedef's need to cancel THIS)
}


Requires tools.f


#USER
CELL +USER (this)
TO #USER

true constant [debug]


0 value (type)   \ Current type's XT, changes with each last keyword parsed
0 value targettype>

string: combo
0 value working   here to working 256 /allot
32 stack: hints     \ Inference stack, XT's of types
 0 hints push
0 value with?    \ Counter - if 0 then we are not in "with" mode.
true value dorothy  \ enable/disable dorothy interpreter
0 value defining-dorothy-word?
0 value to?    \ set to true when FATHOMing the predicate of TO
0 value pointer-manip   \ holds xt of pointer for predicate of TO
0 value ref-manip
0 value remaining
0 value defining-method?

\ 16 stack: workings
\ : +working  working  workings  push  256 allocate drop to working ;
\ : -working  working free drop   workings pop  to working ;

: compile  0< if compile, else execute then ;

: ?compile   state @ if compile else drop execute then ;

: at-col    ( n col -- )
   get-xy nip at-xy ;

: +working ;
: -working ;

: type>  targettype> ; \ (type) >body ;


: /SPLIT  ( a m b n -- b n a m-n )  DUP >R  2SWAP  R> - ;

: keyword   ( addr c -- remaining c  keyword c )
   2dup [char] . scan /split 2swap 1 /string 2swap ;

: is-expression?
   keyword 0> nip swap 0> and nip ;

: last-keyword?  remaining 1 < ;

: hint   ( -- xt )
   hints top @ ;

: any.<< ( -- )
   1 +to with?
   type> body> hints push
   state @ if
      [+asm]
         (this) [u] push
         ebx  (this) [u]  mov
         pop(ebx)
      [-asm]
   else
      (this) !
   then ; immediate

: >>  ( -- )
   -1 +to with?
   hints discard
   state @ if
      [+asm]
         (this) [u] pop
      [-asm]
   then ; immediate


: (method)
   defining-method? if
      r>  @  -1 ?compile
   else
      postpone any.<<
      r>  @  -1 ?compile
      postpone >>
   then ;


: target.ofs ;
: target.val ;
: target.type   cell+ ;
: target.count   cell+ cell+ ;


: typedef.size   ;
: typedef.parent  cell+ ;
: typedef.typesize cell+ cell+ ;

: sizeof   typedef.size @ ;



\ -- Target flavors --
\ Targets can be:
\  this
\  local          addr , type , count , dynamic? ,
\  ref            addr , type , count ,
\  constref       addr , type , count ,
\  type.field     ofs , type , count ,
\  type.pointer   ofs , type , count ,
\  type           size , parent , type-size , constructor , destructor , p..


0 value target>

: !target
   dup to target> ;

: (typedef)  r>      dup body> to (type)
                     working count is-expression? if drop exit then  \ Enables casting
                     state @ if postpone literal then ;

: (ref)   r>         !target dup target.type @ body> to (type)
                     to? last-keyword? and if body> to ref-manip exit then  \ because of TO-POINTER
                     state @ if postpone literal postpone @ else @ then ;

: (constref)   r>    !target dup target.type @ body> to (type)
                     @ state @ if postpone literal then ;

: (field)   r>       !target dup target.type @ body> to (type)
                     @ state @ if postpone literal postpone + else + then ;

: (pointer)   r>     !target dup target.type @ body> to (type)
                     to? last-keyword? and if body> to pointer-manip exit then \ Pointer xt will be retrieved again
                     @ state @ if postpone literal postpone + postpone @ else + @ then ;

: this               \ TODO: get the type of "this" and store in (type) ?
                     state @ if postpone (this) postpone @ else (this) @ then  ; immediate

: is-a-type?   ( addr c -- flag )
   (find) if
      parent ['] (typedef) =
   else false then ;

\ -- Parser --

: .append   2swap combo place " ." combo append combo append combo count ;

: .prepend  2swap .append ;

\ prepend keyword with current type
: qualify  ( keyword c type-xt -- word c )
   >name count .prepend ;

\ -- Dorothy interpreter --

\ try qualifying with current type and then its ancestors
\  if none is found, try just looking up the keyword
: determine  ( keyword c -- xt n found-type-xt )
   locals| c temp |
   (type) dup >body to targettype>  begin
      dup 0= over 0< or if
         drop
         temp c is-known?   ?dup  ( xt true true | false ) if 0 exit then
         123 throw  \ probably a number
      then
      temp c third qualify
      [defined] [debug] [if] bold .s  60 at-col  2dup type space normal [then]
      is-known? ?dup 0= while
      2drop >body typedef.parent @ body>
   repeat
   rot ;

: lookup
   is-known? 0= if drop drop 0 then ;

: descendent-or-equal?   ( ancestor typedef -- flag )
   begin dup while
      2dup = ?dup if nip nip exit then
      typedef.parent @
   repeat
   nip ;

0 value implicit?  \ gives ?THIS the final if it should compile THIS or not into the def

-? 0 value xt
: ?this
   \ first keyword: determine type; if it's HINT or an ancestor, and WITH? > 0, and the keyword is not a method, compile THIS
   with? if
      2dup keyword 2nip determine swap if
         hint  >body swap >body    descendent-or-equal? if
            \ dup parent ['] (typedef) <> swap
            [defined] [debug] [if] ." Implicit THIS check " [then]
            parent ['] (method) <> implicit? and if postpone this then
            exit
         then
      else
         drop
      then
      drop
   then ;

: (fathom)
   with? to implicit?
   hint to (type)
   ?this
   begin dup 0> while
      keyword 2swap  dup to remaining  2>r determine drop ?compile  2r>
   repeat  2drop ;

: fathom  ( c-addr len -- true | c-addr len false )
   working place working count
   ['] (fathom) catch ?dup if
      dup 123 <> if ." FATHOM THREW UP: " . else drop then
      false
   else
      true
   then
   ;

\ : infer?
\    with?  defining-dorothy-word?  or  ;


: dorothy-engine
   fathom ?exit
   UNKNOWN-TOKEN ;

: !type
   dup to (type) >body to targettype> ;

: ?>type
   2dup working place
   2dup is-expression? if
      2dup keyword 2nip lookup ?dup if !type then
   else
      with? if
         fathom not exit
      then
   then
   true
   ;

: dorothy-interpreter
   ?>type if word-interpreter then ;

: dorothy-compiler
   ?>type if  word-compiler  then ;

: dorothy-INTERPRETING ( -- flag )
   BEGIN
      STATE @ 0= WHILE
      BL WORD DUP C@ WHILE
      COUNT dorothy-INTERPRETER ?STACK
   REPEAT 0<> ELSE 0 THEN ;

: dorothy-COMPILING ( -- flag )
   BEGIN
      STATE @ WHILE
      BL WORD DUP C@ WHILE
      COUNT dorothy-COMPILER ?STACK
   REPEAT 0<> ELSE 0 THEN ;


\ -- Delegates -- in place of interfaces for now

\ to be used directly after type declarations (the TYPE: line)
\  structure:
\   typedef offset ,
: delegate ( struct -- <name> struct )
   locals| struct |
   create

   struct typedef.typesize @ ,
   cell struct typedef.typesize +!
   struct

   does> ( p.. typedef -- )
      @ + @ execute ;

: >delegate  ( xt -- <type> <delegate> )
   ' >body ' >body @ + ! ;

\ -- Defining types --

: Typedef:   header postpone (typedef) immediate ;

typedef: typedef  0 , 0 , 5 cells ,
typedef: target   0 , 0 , 4 cells ,

Typedef: any  0 , 0 , 3 cells , 16 cells /allot
any
delegate construct  :noname   drop ; >delegate any construct
delegate destruct   :noname   drop ; >delegate any destruct
drop

0 value last-size

: fieldarray ( struct type n -- <name> struct )
   locals| n type struct |
   " header " pad place
   struct body> >name count bl parse .append pad append
   pad count evaluate  immediate
   postpone (field)
   struct @ dup to last-size ,
   type ,
   n ,
   type sizeof n * struct +!
   struct  ;

: field   1 fieldarray ;



\ ---------------------------------------- BEGIN API ---------------------------------------------


: Extend:   ( type -- <name> )
   Typedef: here swap dup dup sizeof , , typedef.typesize @+ dup , here >r dup allot r> swap move  16 cells /allot ;

: Type:  any extend: ;

: End-type   drop ;

: reopen  ' >body ;
: goback   last-size over ! ;
: skip   @ over +! ;
: nskip   over +! ;
: union  0 over ! ;


\ -- Field base-types --

aka 2@ (2@)

any extend: int   cell nskip  end-type
macro: int.@  @ ;
macro: int.!  ! ;
macro: intp+!  +! ;
macro: int.clear   off ;
macro: int.on   on ;
macro: int.off   off ;
macro: int.?    ? ;
macro: int.2@   (2@) swap ;
macro: int.3@   @+ swap @+ swap @ ;

any extend: short   2 nskip  end-type
macro: short.@  h@ ;
macro: short.!  h! ;
macro: shortp+!  h+! ;
macro: short.clear  0 swap h! ;
macro: short.on   -1 swap h! ;
macro: short.off   short.clear ;
macro: short.?    h@ . ;
macro: short.2@   2h@ ;
macro: short.2!   2h! ;

any extend: ushort   2 nskip  end-type
macro: ushort.@  w@ ;
macro: ushort.!  w! ;
macro: ushortp+!  w+! ;
macro: ushort.clear  0 swap w! ;
macro: ushort.on   -1 swap w! ;
macro: ushort.off   ushort.clear ;
macro: ushort.?    w@ . ;
\ macro: ushort.2@   2w@ ;

any extend: byte  1 nskip  end-type
macro: byte.@  c@ ;
macro: byte.!  c! ;
macro: bytep+!  c+! ;
macro: byte.clear  0 swap c! ;
macro: byte.on   -1 swap c! ;
macro: byte.off   byte.clear ;
macro: byte.?    c@ . ;
macro: byte.2@    c@+ swap c@ ;


\ -- Refs --

: any.ref  ( object -- <name> )
   header postpone (ref) immediate
   , type> , 1 , ;

: any.ref[]  ( n addr -- <name> )
   header postpone (ref) immediate
   , type> , , ;

\ -- Constrefs --

: any.const  ( object -- <name> )
   header postpone (constref) immediate
   , type> , 1 , ;

: any.make  ( -- <name> )
   here type> sizeof  /allot any.const ;

: any.make[]  ( n -- <name> )
   header postpone (constref) immediate
   here cell+ cell+ cell+ , type> , dup ,
   type> sizeof * /allot ;

\ -- Fields --

: any.field  ( struct -- <name> struct )
   type> field ;

: any.field[]  ( struct n -- <name> struct )
   type> swap fieldarray ;

: any.skip
   type> skip ;

\ -- Pointers --

: pointer[]
   locals| n type struct |
   " header " pad place
   struct body> >name count bl parse .append pad append
   pad count evaluate  immediate
   postpone (pointer)  struct @ , type , n ,
   cell struct +!
    struct ;

: pointer
   1 pointer[] ;

: any.pointer
   type> pointer ;

: any.pointer[]  ( struct n -- <name> struct )
   type>  swap pointer[] ;

\ -- Ability to modify refs and pointers --

: (to-ref)   >body state @ if  postpone literal  postpone !  exit  then   ! ;
: (+to-ref)   >body state @ if  postpone literal  postpone +!  exit  then   +! ;
: (&of-ref)   >body state @ if  postpone literal  then  ;

: ?2drop  dup 0= if nip nip then ;

: to-ref ( xt -- flag )
   locals| xt |
   >in @ >r
   true to to?
   0 to ref-manip
   bl parse fathom  ?2drop  ref-manip parent ['] (ref) = and if
      ref-manip xt execute  r> drop  true
   else
      r> >in !  false
   then
   false to to? ;

: (to-pointer)   >body @  state @ if  postpone literal  postpone +  postpone !  exit  then   + ! ;
: (+to-pointer)   >body @  state @ if  postpone literal  postpone +  postpone +!  exit  then   + +! ;
: (&of-pointer)   >body @  state @ if  postpone literal  postpone +  exit  then   + ;

: ?'  bl parse (find) 0= if false then ;

: to-pointer ( xt -- flag )
   locals| xt |
   >in @ >r
   ?'  parent  ['] (value)  =  if  false r> >in ! exit then
   r@ >in !
   true to to?
   0 to pointer-manip
   bl parse fathom   ?2drop  pointer-manip parent ['] (pointer) =  and  if
      pointer-manip xt execute r> drop  true
   else
      r> >in ! false
   then
   false to to? ;


\ TODO: the order of the checks will depend on if the next word is an expression or not , following the same
\  rules as DOROTHY.compileR
-? : to ( n -- )
             ['] (to-pointer) to-pointer ?exit
   lvar-comp to-local ?exit
             to-value ?exit
             ['] (to-ref) to-ref ?exit
             1 'method ! ; immediate
-? : +to ( n -- )
             ['] (+to-pointer) to-pointer ?exit
   lvar-comp +to-local ?exit
             +to-value ?exit
             ['] (+to-ref) to-ref ?exit
             2 'method ! ; immediate
-? : &of ( -- addr )
             ['] (&of-pointer) to-pointer ?exit
   lvar-comp &of-local ?exit
             &of-value ?exit
             ['] (&of-ref) to-ref ?exit
             3 'method ! ; immediate


\ -- Put it all together --

0 value (topic)

: topic>   (topic) state @ if postpone literal then ; immediate


: ?dorothy-word
   locals| name |
   name count is-expression?
   dup if
      name count keyword 2nip is-a-type? dup
         if name count keyword 2nip (find) drop
         dup >body to (topic)
         hints push then   \ push the type onto the inference stack
      and
   then
   to defining-dorothy-word? ;

\ doing ' is impossible because an expression can expand to multiple words
{ : (') ( "name" -- xt )
   BL WORD  DUP C@ HUH?  FIND ?dup 0= if
      count ['] determine catch .s 0=
   then
   HUH? ; }


: (:)   : last @ ?dorothy-word ;

\ macros are a special case in that they work by evaluating the code as a string
\  so they need to push their type onto the inference stack when the macro is executed.
: (macro:)
   : immediate postpone (s") [char] ; string  \ compile code as string
   last @ ?dorothy-word
   hint " literal hints push evaluate ; " evaluate  \ compile the code to interpret it ( ; will discard the hint )
   hints discard ;

: (:noname)
   false to defining-dorothy-word?
   :noname   ;

: (;)
   0 to with?
   postpone ;
   defining-dorothy-word? if hints discard then
   false to defining-dorothy-word?
   false to defining-method?
   hints clear-stack
   0 hints push
   ; immediate


: -evaluate
   false to dorothy  evaluate  true to dorothy ;


: method:
   true to defining-method?
   header postpone (method) immediate
   here 0 ,
   last @ >r  (:noname)  r> ?dorothy-word     1 to with?   swap !  ;

: :: ' compile, ; immediate

-? : see
   ' dup parent ['] (method) = if
      >code $b + dasm
   else
      >code dasm
   then ;


: -dorothy  false to dorothy ;
: +dorothy  true to dorothy ;


requires Heap.f



\ copy the contents of an object to another object of the same type
: any.copy   ( object object -- )
   state @ if
      " [ type> sizeof ] literal move " -evaluate
   else
      type> sizeof move
   then ; immediate

: any.new
   state @ if
      " [ type> sizeof ] literal chunk dup [ type> ] literal construct " -evaluate
   else
      type> sizeof chunk dup type> construct
   then ; immediate

: any.dispose
   state @ if
      " dup [ type> ] literal destruct recycle " -evaluate
   else
      dup type> destruct recycle
   then ; immediate

: anyp*
   state @ if
      " [ type> sizeof ] literal * " -evaluate
   else
      type> sizeof *
   then ; immediate

\ Used to compile a routine from the nearest ancestor; makes it possible to extend any routine.
: super
   (type) >body typedef.parent @ body> to (type) ; immediate

: go
  "  -? aka (:) : " evaluate
  \ "  -? aka (macro:) macro: " evaluate
  "  -? aka (:noname) :noname " evaluate
  "  -? aka (;) ; immediate " evaluate
  ['] dorothy-engine is not-defined
  ['] dorothy-interpreting is interpreting
  ['] dorothy-compiling is compiling
;


:prune
   ['] UNKNOWN-TOKEN is not-defined
   ['] (interpreting) is interpreting
   ['] (compiling) is compiling ;



go

requires quotations.f

-? : :[] ( -- <name> )
   create here 0 , immediate does-:[
   last @ :noname swap ?dorothy-word swap ! postpone r@ postpone >quote ;


requires collections.f


int extend: rgba32
   union
   byte.field r
   byte.field g
   byte.field b
   byte.field a
end-type

